home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PBLIB1
/
PROGS
/
TLISTER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-05-03
|
7KB
|
246 lines
(*PAGE*)
PROGRAM TLISTER;
Uses DOS, CRT, PbCRT, PbMISC, PbDATA, PbOBJS, PbHIGH, PbPARMS;
{
Description : Pascal Source file printer
Author : Howard Richoux
Date : 11/89
Last revised: lots over a long time
2/18/94 3.02 NEW LIBRARIES
Application : IBM PC and compatibles, done in Turbo Pascal 7.0
Status : Placed in the Public Domain by HNR Software 1/29/94
Published in: none
}
var S : string;
outfile : string[40];
fname : string[40];
var L : OUT_object_1;
compressed : boolean;
InterfaceOnlyFlag : boolean;
{*****************************************************************}
Function Command(line : string) : boolean;
var i : integer;
begin
Command := false;
if (copy(line,1,6) = '(*PAGE') or (copy(line,1,5) = '{PAGE') then
begin
Command := true;
i := length(line);
if i > 9 then L.pagelabel1 := copy(line,7,i-9);
L.donewithpage;
end;
end;
Procedure ListFile(fname : string);
var line,cmd : string;
done : boolean;
tx : TFILE_object;
begin
if not FileExists(fname) then
begin
writeln('');
writeln('Listfile - file not found [',fname,']');
exit;
end;
writeln('Listing file ',fname);
L.ResetCounts;
pCurrFName := UpCaseStr(fname);
L.pagelabel1 := Packtimestr(FileDate(pCurrFname,''));
tx.init(pCurrFName,false);
done := false;
while tx.fetchnext(line) and not done do
begin
if not Command(line) then
begin
L.out(line);
if InterfaceOnlyFlag then
begin
cmd := UpCaseStr(leftstr(line,14));
trim(cmd);
if cmd = 'IMPLEMENTATION' then done := true;
end;
end;
if keypressed then done := true;
end;
tx.done;
L.donewithpage;
end;
Function IsThisUnitFile(fname : string) : boolean;
{check the first 100 lines for the word 'INTERFACE'}
var line : string;
count, printed : integer;
done : boolean;
found : boolean;
tx : TFILE_object;
begin
found := false;
done := false;
count := 200; printed := 0;
pCurrFName := UpCaseStr(fname);
tx.init(pCurrFName,false);
while tx.fetchnext(line) and not done do
begin
trim(line);
if leftstr(UpCaseStr(line),9) = 'INTERFACE' then found := true;
if keypressed then done := true;
inc(printed);
if printed > count then done := true;
if found then done := true;
end;
tx.done;
if found and pDEBUG then
writeln('IsThisUnitFile? ',leftstr(fname,24),' YES')
else if pDEBUG then
writeln('IsThisUnitFile? ',leftstr(fname,24),' NO');
IsThisUnitFile := found;
end;
Function LocateFile(var fn : string) : boolean;
var i :integer;
found : boolean;
begin
found := true;
if FileExists(fn + '.pas') then fn := fn + '.pas'
else if FileExists(fn + '.txt') then fn := fn + '.txt'
else if FileExists(fn + '.doc') then fn := fn + '.doc'
else found := false;
if InterfaceOnlyFlag and (not IsThisUnitFile(fn)) then
found := false;
LocateFile := found;
end;
Function ExcludeFile(var fn : string) : boolean;
var exclude : boolean;
exten : string[4];
begin
exten := UpCaseStr(rightstr(fn,4));
if exten = '.OBJ' then exclude := true
else if exten = '.EXE' then exclude := true
else if exten = '.COM' then exclude := true
else if exten = '.MAP' then exclude := true
else if exten = '.LST' then exclude := true
else if exten = '.ARC' then exclude := true
else if exten = '.ZIP' then exclude := true
else if exten = '.BAK' then exclude := true
else if exten = '.TPU' then exclude := true
else exclude := false;
if InterfaceOnlyFlag and (not IsThisUnitFile(fn)) then
exclude := true;
ExcludeFile := exclude;
end;
Procedure ListFiles(fn : string);
var SR :searchrec;
i : integer;
fname : string[80];
fnarray : STRA_object;
begin
fname := fn;
i := Pos('.',fname);
if i = 0 then
begin
if LocateFile(fname) then ListFile(fname);
end
else begin
i := Pos('*',fname);
if i = 0 then Listfile(fname)
else begin
fnarray.init(100);
GetfilesSTRA(fname,fnarray,fNoSort);
if fnarray.count > 0 then
begin
fnarray.sort;
for i := 1 to fnarray.count do
begin
s := fnarray.fetchN(i);
if not ExcludeFile(s) then ListFile(s);
end;
end;
fnarray.done;
end;
end;
end;
Procedure Init;
var yy,mm,dd : word;
fname,temp,hdr : string;
i : integer;
begin
addparm(1,'OUT','');
addparm(1,'APPEND','NO');
addparm(1,'INTERFACE','NO');
addparm(1,'COMPRESSED','NO');
StandardpVarsInit; { PARMunit standard variables }
InterfaceOnlyFlag := CheckOK('INTERFACE');
compressed := CheckOK('COMPRESSED');
Outfile := UpCaseSTr(GetParmStr('OUT'));
if outfile <> '' then
begin
if CheckOK('APPEND') then
writeln('appending to: ',outfile)
else writeln('listing to: ',outfile);
L.LISTinit(outfile,OUT_typAPPEND);
if compressed then L.SetCompressed;
hdr := '@LABEL1 |@FILE|Page @PAGE';
if InterfaceOnlyFlag then
hdr := '@LABEL1 |@FILE|(INTERFACE ONLY) Page @PAGE';
L.SetHeaders(hdr,' ','',
'||@PROGID',' ');
L.LISTOpen;
end;
end;
(* Main program *)
BEGIN
pProgID := 'TLISTER 3.02';
Init;
fname := 'x';
if ParamCount > 0 then
begin
fname := UpCaseStr(paramstr(1));
if fname = 'HELP' then ShowDocFile
else if fname = 'STATUS' then ListParms(0)
else begin
ListFiles(fname);
L.done;
writeln('');
writeln('LISTER done');
end;
end
else ShowDocFile;
end.